home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / bbs_util / cdesc110.zip / CDESC.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-12  |  13KB  |  448 lines
  1. {$M 8192,0,10240}  { 10k reserved for data }
  2. {$N-,E- no math support needed}
  3. {$X- function calls may not be discarded}
  4. {$I- disable I/O checking (trap errors by checking IOResult)}
  5.  
  6. PROGRAM Create_Description_Files;
  7.  
  8. {===========================================================================}
  9.                       (** Global declarations **)
  10. {===========================================================================}
  11.  
  12. USES DOS, ArcID, ImageID;
  13. CONST
  14.   progdesc = 'CDesc v1.10 - Free DOS utility: Create a descriptive list of specified files.';
  15.   author   = 'Copyright (c) April 12, 1996 by David Daniel Anderson - Reign Ware.';
  16.   Divider = '───────────────────────────────────────────────────────────────────────────────';
  17. VAR
  18.   unARC, unARJ, unHAP, unLZH, unPAK,
  19.   unRAR, unUC2, unZIP, unZOO,
  20.   unHA, unHPK, unHYP, unSQZ: STRING;
  21.  
  22. {===========================================================================}
  23.                   (** Custom help & exit procedure **)
  24. {===========================================================================}
  25.  
  26. VAR SavedExitProc: POINTER;
  27. FUNCTION WordToHex (W: WORD): STRING; FORWARD;
  28.  
  29. PROCEDURE CustomExit; FAR;
  30. {---- Always exit through here ----}
  31. CONST
  32.   usage    = 'Usage:    CDesc <files_to_query> <text_file_output>';
  33.   example  = 'Example:  CDesc c:\download\*.* files.bbs';
  34.   note     = 'Note: DOS wildcards may be used when specifying the files to query.';
  35.  
  36. VAR
  37.   message: STRING [79];
  38. BEGIN
  39.   ExitProc := SavedExitProc;
  40.   IF (ExitCode > 0) THEN BEGIN
  41.     WriteLn (usage);
  42.     WriteLn (example);   WriteLn;
  43.     WriteLn (note);      WriteLn;
  44.   END;
  45.   IF ErrorAddr <> NIL THEN
  46.   BEGIN
  47.     WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
  48.     WriteLn ('Address = ', WordToHex (Seg (ErrorAddr^)), ':', WordToHex (Ofs (ErrorAddr^)));
  49.     WriteLn ('Code    = ', ExitCode);
  50.     ErrorAddr := NIL;
  51.   END
  52.   ELSE
  53.     IF (ExitCode > 0) AND (ExitCode < 255) THEN BEGIN
  54.       CASE ExitCode OF
  55.         2 : message := 'No files found.  First parameter must be a valid file specification.';
  56.         7 : message := 'File handling error.  Text file is most likely incomplete - or nonexistent.';
  57.         ELSE  message := 'Unknown error.';
  58.       END;
  59.       WriteLn ('Error encountered, number ', ExitCode, ':'); WriteLn (message);
  60.     END;
  61. END;
  62.  
  63. {===========================================================================}
  64.                      (** Supporting subroutines **)
  65. {===========================================================================}
  66.  
  67. CONST
  68.   HexDigits : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  69.  
  70. FUNCTION ByteToHex (B: BYTE): STRING; {Convert a BYTE var to Hex string}
  71. BEGIN
  72.   ByteToHex := Concat (HexDigits [B SHR 4], HexDigits [B AND $F]);
  73. END;
  74.  
  75. FUNCTION WordToHex (W: WORD): STRING; {Convert a WORD var to Hex string}
  76. BEGIN
  77.   WordToHex := ByteToHex (Hi (W)) + ByteToHex (Lo (W));
  78. END;
  79.  
  80. PROCEDURE CheckIO;
  81. BEGIN
  82.   IF IOResult <> 0 THEN Halt (7);
  83. END;
  84.  
  85. FUNCTION LZero (CONST w: WORD): STRING;
  86. VAR
  87.   s : STRING;
  88. BEGIN
  89.   Str (w : 0, s);
  90.   IF (Length (s) = 1) THEN
  91.     s := '0' + s;
  92.   LZero := s;
  93. END;
  94.  
  95. FUNCTION LowerStr (w: STRING): STRING;
  96. VAR
  97.   cp  : INTEGER;        {The position of the character to change.}
  98. BEGIN
  99.   FOR cp := 1 TO Length (w) DO
  100.     IF w [cp] in ['A'..'Z'] THEN
  101.       System.Inc (w [cp], 32);
  102.   LowerStr := w;
  103. END;
  104.  
  105. FUNCTION RPad (bstr: STRING; CONST len: BYTE): STRING;
  106. BEGIN
  107.   WHILE (Length (bstr) < len) DO
  108.     bstr := bstr + #32;
  109.   RPad := bstr;
  110. END;
  111.  
  112. FUNCTION RTrim (InStr: STRING): STRING;
  113. BEGIN
  114.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr) ] IN [#0, #9, #32]) DO
  115.     system. Dec (InStr [0]);
  116.   RTrim := InStr;
  117. END;
  118.  
  119. FUNCTION LTrim (InStr: STRING): STRING;
  120. BEGIN
  121.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  122.     Delete (InStr, 1, 1);
  123.   LTrim := InStr;
  124. END;
  125.  
  126. FUNCTION Trim (InStr: STRING): STRING;
  127. BEGIN
  128.   Trim := RTrim (LTrim (InStr));
  129. END;
  130.  
  131. FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
  132. VAR
  133.   Attr  : WORD;
  134.   cFile : FILE;
  135. BEGIN
  136.   Assign (cFile, FileName);
  137.   GetFAttr (cFile, Attr);
  138.   IF (DosError = 0) AND ((Attr AND Directory) = Directory)
  139.     THEN IsDir := TRUE
  140.     ELSE IsDir := FALSE;
  141. END;
  142.  
  143. FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
  144. VAR
  145.   Attr  : WORD;
  146.   cFile : FILE;
  147. BEGIN
  148.   Assign (cFile, FileName);
  149.   GetFAttr (cFile, Attr);
  150.   IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
  151.     THEN IsFile := TRUE
  152.     ELSE IsFile := FALSE;
  153. END;
  154.  
  155. PROCEDURE EraseFile (CONST FileName : STRING);
  156. VAR
  157.   cFile : FILE;
  158. BEGIN
  159.   IF IsFile (FileName) THEN BEGIN
  160.     Assign (cFile, FileName);
  161.     SetFAttr (cFile, 0);
  162.     Erase (cFile); CheckIO;
  163.   END;
  164. END;
  165.  
  166. {===========================================================================}
  167.                       (** Primary subroutines **)
  168. {===========================================================================}
  169.  
  170. FUNCTION GetFilePath (CONST PSTR: STRING; VAR ZDir: DIRSTR): PATHSTR;
  171. VAR
  172.   dirinfo   : SEARCHREC;
  173.   jPath     : PATHSTR;  { file path,       }
  174.   jDir      : DIRSTR;   {      directory,  }
  175.   jName     : NAMESTR;  {      name,       }
  176.   jExt      : EXTSTR;   {      extension.  }
  177. BEGIN
  178.   jPath := PStr;
  179.   IF IsDir(jPath) THEN BEGIN
  180.     IF NOT (jPath[Length(jPath)] in [':','\']) THEN
  181.       jPath:=jPath+'\';
  182.     jPath:=jPath+'*.*';
  183.   END;
  184.  
  185.   FSplit (FExpand (jPath), jDir, jName, jExt);
  186.   jPath := jDir+jName+jExt;
  187.  
  188.   ZDir := jdir;
  189.   GetFilePath := jpath;
  190. END;
  191.  
  192. PROCEDURE InitUnArchivers;
  193. VAR
  194.   epath, cpath   : PATHSTR;
  195.   {epath & cpath are fully qualified pathnames of .exe & .cfg files}
  196.   edir: DIRSTR; ename: NAMESTR; eext: EXTSTR;
  197.   CfgFile        : TEXT;
  198.   CfgLine,
  199.   CfgVar, CfgVal : STRING [80];
  200.   equalPos       : BYTE;
  201.  
  202. BEGIN
  203.   epath := (ParamStr (0));
  204.   FSplit (FExpand (epath), edir, ename, eext); { break up path into components }
  205.   cpath := edir + ename + '.cfg';
  206.  
  207.   unARC := 'pkxarc';
  208.   unARJ := 'arj e -y';
  209.   unLZH := 'lha e -n2 -m+ -c+';
  210.   unHAP := 'pah e';
  211.   unPAK := 'pak e /wa';
  212.   unRAR := 'rar e';
  213.   unUC2 := 'uc e -f';
  214.   unZIP := 'pkunzip -# -o';
  215.   unZOO := 'zoo -extract';
  216.  
  217.   unHA    := 'ha ey';
  218.   unHPK := 'hpack x -oa';
  219.   unHYP := 'hyper -xo';
  220.   unSQZ   := 'sqz e /o1';
  221.  
  222.   IF IsFile (cpath) THEN
  223.   BEGIN
  224.     Assign (CfgFile, cpath);
  225.     Reset (CfgFile); CheckIO;
  226.     IF NOT EOF (CfgFile) THEN
  227.     REPEAT  { find vars }
  228.       ReadLn (CfgFile, CfgLine);
  229.       equalPos := Pos ('=', CfgLine);
  230.       IF (Length (CfgLine) > 10) THEN BEGIN
  231.  
  232.         CfgVar := Trim (LowerStr (Copy (CfgLine, 1, equalPos - 1)));
  233.         CfgVal := Trim (Copy (CfgLine, equalPos + 1, Length (CfgLine) - equalPos));
  234.  
  235.         IF (CfgVar = 'unARC') THEN
  236.           unARC := CfgVal
  237.         ELSE IF (CfgVar = 'unARJ') THEN
  238.           unARJ := CfgVal
  239.         ELSE IF (CfgVar = 'unHAP') THEN
  240.           unHAP := CfgVal
  241.         ELSE IF (CfgVar = 'unLZH') THEN
  242.           unLZH := CfgVal
  243.         ELSE IF (CfgVar = 'unPAK') THEN
  244.           unPAK := CfgVal
  245.         ELSE IF (CfgVar = 'unRAR') THEN
  246.           unRAR := CfgVal
  247.         ELSE IF (CfgVar = 'unUC2') THEN
  248.           unUC2 := CfgVal
  249.         ELSE IF (CfgVar = 'unZIP') THEN
  250.           unZIP := CfgVal
  251.         ELSE IF (CfgVar = 'unZOO') THEN
  252.           unZOO := CfgVal
  253.         ELSE IF (CfgVar = 'unHA') THEN
  254.           unHA := CfgVal
  255.         ELSE IF (CfgVar = 'unHPK') THEN
  256.           unHPK := CfgVal
  257.         ELSE IF (CfgVar = 'unHYP') THEN
  258.           unHYP := CfgVal
  259.         ELSE IF (CfgVar = 'unSQZ') THEN
  260.           unSQZ := CfgVal
  261.  
  262.       END;
  263.     UNTIL EoF (CfgFile); { loop back to read another line }
  264.     Close (CfgFile); CheckIO;
  265.   END;
  266. END;
  267.  
  268. FUNCTION ExtractFile (CONST ArchiveFile, FileToEx: STRING; ExCMD : STRING): BOOLEAN;
  269. BEGIN
  270.   ExCMD := ExCMD + #32 + ArchiveFile + #32 + FileToEx;
  271.   SwapVectors;
  272.     Exec (GetEnv ('COMSPEC'), ' /c '+ExCMD+' >nul');
  273.   SwapVectors;
  274.   ExtractFile := IsFile (FileToEx)
  275. END;
  276.  
  277. FUNCTION IsArchive (CONST SomeFile: STRING): STRING;
  278. VAR
  279.   ExCMD : STRING;
  280.   FileID : ARCTYPE;
  281. BEGIN
  282.   ExCMD := '';
  283.   FileID := IsArc (SomeFile);
  284.   IF FileID <> NONE THEN BEGIN
  285.  
  286.      CASE FileID OF
  287.        ARC : ExCMD := unARC;
  288.        ARJ : ExCMD := unARJ;
  289.        HAP : ExCMD := unHAP;
  290.        LZH : ExCMD := unLZH;
  291.        PAK : ExCMD := unPAK;
  292.        RAR : ExCMD := unRAR;
  293.        UC2 : ExCMD := unUC2;
  294.        ZIP : ExCMD := unZIP;
  295.        ZOO : ExCMD := unZOO;
  296.        HA  : ExCMD := unHA ;
  297.        HPK : ExCMD := unHPK;
  298.        HYP : ExCMD := unHYP;
  299.        SQZ : ExCMD := unSQZ;
  300.      END;
  301.  
  302.      IF ExCMD <> '' THEN WriteLn ('Extracting with: ', ExCMD);
  303.   END;
  304.   IsArchive := ExCMD;
  305. END;
  306.  
  307. PROCEDURE WriteFileInfo (VAR TXTfile: TEXT; CONST dirinfo: SEARCHREC);
  308. VAR
  309.   FSize       : STRING;
  310.   DateTimeInf : DATETIME;
  311. BEGIN
  312.   Str (DirInfo. Size, FSize);
  313.   UnpackTime (DirInfo. Time, DateTimeInf);
  314.   WITH DateTimeInf DO
  315.   BEGIN
  316.     Write (TXTfile, RPad (DirInfo. Name, 12), (FSize): 9, #32#32,
  317.     LZero (Month) , '-', LZero (Day)   , '-', Copy (LZero (Year), 3, 2), #32#32);
  318.   END;
  319. END;
  320.  
  321. PROCEDURE ProcessDesc (VAR TXTfile: TEXT; CONST DescName: STRING);
  322. VAR
  323.   DIZfile: TEXT;
  324.   DIZline: STRING;
  325.   PadLen: BYTE;
  326.   FirstLine: BOOLEAN;
  327. BEGIN
  328.   Assign (DIZFile, DescName);
  329.   Reset (DIZFile); CheckIO;
  330.   Write ('Adding description to output file ... ');
  331.  
  332.   FirstLine := TRUE;
  333.   DIZline := '';
  334.   PadLen := 0;
  335.   IF NOT EOF (DIZFile) THEN
  336.   REPEAT
  337.     ReadLn (DIZfile, DIZline);
  338.     IF Trim (DIZline) <> '' THEN BEGIN
  339.       WriteLn (TXTfile, RTrim (RPad ('', PadLen) + DIZline));
  340.       IF FirstLine THEN BEGIN
  341.         FirstLine := FALSE;
  342.         PadLen := 33;
  343.       END;
  344.     END;
  345.   UNTIL EoF (DIZfile);
  346.   IF FirstLine THEN WriteLn (TXTfile, 'Description not found');
  347.  
  348.   WriteLn ('done!');
  349.   Close (DIZFile); CheckIO;
  350.   EraseFile (DescName);
  351. END;
  352.  
  353. PROCEDURE ProcessFile (CONST FileQuerying, TXTpath: STRING; VAR TXTfile: TEXT; CONST fileinfo: SEARCHREC);
  354. CONST
  355.   DIZfileName = 'FILE_ID.DIZ';
  356.   SDIfileName = 'DESC.SDI';
  357. VAR
  358.   ExCMD,
  359.   iType: STRING;
  360.   iWidth, iHeight: LONGINT;
  361.   iColors, GIFLite: STRING;
  362.  
  363. BEGIN
  364.   EraseFile (DIZfileName);
  365.   EraseFile (SDIfileName);
  366.  
  367.   WriteLn ('Processing: ', FileQuerying);
  368.   WriteFileInfo (TXTfile, fileinfo);
  369.  
  370.   ExCMD := IsArchive (FileQuerying);
  371.   IF (ExCMD <> '') AND
  372.      (ExtractFile (FileQuerying, DIZfileName, ExCMD) OR
  373.       ExtractFile (FileQuerying, SDIfileName, ExCMD))
  374.      THEN BEGIN
  375.        IF IsFile (DIZfileName) THEN ProcessDesc (TXTfile, DIZfileName) ELSE
  376.          IF IsFile (SDIfileName) THEN ProcessDesc (TXTfile, SDIfileName);
  377.      END
  378.      ELSE BEGIN
  379.        iType := IsImage (FileQuerying, iWidth, iHeight, iColors, GIFLite);
  380.        IF (iType <> '') THEN BEGIN
  381.           WriteLn ('Assuming file is a: ', iType);
  382.           Write ('Adding description to output file ... ');
  383.           WriteLn (TXTfile, RPad(iType,6), ' [':2, iWidth:4, iHeight:5, iColors:7, #32#32, GIFLite:6);
  384.           WriteLn ('done!');
  385.        END
  386.        ELSE BEGIN
  387.          WriteLn ('No description available for: ', FileQuerying, '.');
  388.          WriteLn (TXTfile, 'No description available.');
  389.        END;
  390.      END;
  391.   Writeln (Divider);
  392. END;
  393.  
  394. {===========================================================================}
  395.                           (** Main program **)
  396. {===========================================================================}
  397.  
  398. CONST
  399.   Hdr = 'Filename       Size      Date    Description of File Contents';
  400.   Bar = '============ ========  ========  =============================================';
  401.  
  402. VAR
  403.   TXTfile : TEXT;
  404.   fPath,
  405.   TXTPath : PATHSTR;
  406.   fDir,
  407.   TXTDir  : DIRSTR;
  408.   fInfo   : SEARCHREC;
  409.  
  410. BEGIN
  411.   SavedExitProc := ExitProc;
  412.   ExitProc := @CustomExit;
  413.  
  414.   WriteLn (progdesc);
  415.   WriteLn (author);
  416.   Writeln (Divider);
  417.  
  418.   IF ParamCount <> 2 THEN Halt (255);
  419.   InitUnArchivers;
  420.   fPath := GetFilePath (ParamStr (1), fDir);
  421.   FindFirst (fPath, Archive, fInfo);
  422.   IF (DosError <> 0) THEN
  423.     Halt (2);
  424.  
  425.   TXTPath := GetFilePath (ParamStr (2), TXTDir);
  426.   Assign (TXTfile, TXTpath);
  427.   IF IsFile (TXTpath)
  428.     THEN BEGIN
  429.       Append (TXTfile); CheckIO;
  430.     END
  431.     ELSE BEGIN
  432.       Rewrite (TXTfile); CheckIO;
  433.       WriteLn (TXTfile, Hdr);
  434.       WriteLn (TXTfile, Bar);
  435.     END;
  436.  
  437.   DosError := 0;
  438.   WHILE (DosError = 0) DO
  439.   BEGIN
  440.     IF fDir+fInfo.Name <> TXTpath THEN
  441.       ProcessFile (fDir+fInfo.Name, TXTpath, TXTfile, fInfo);
  442.     FindNext (fInfo);
  443.   END;
  444.   Close (TXTfile); CheckIO;
  445.  
  446.   WriteLn ('Mission accomplished!');
  447. END.
  448.